home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #14
/
Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO
/
netmail
/
txtq130.zip
/
TXTQ.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1996-01-26
|
22KB
|
807 lines
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
UNIT TXTQ; (*** Common procedures for ROBOQ, SLMR and SRQ ***)
INTERFACE
USES
DOS,
Heapman;
CONST
MaxBytes = 61440; {60k}
TYPE
MsgArray = ARRAY [1..MaxBytes] OF CHAR;
ConfRec = ^ConfDAT;
ConfDAT = RECORD
Num : WORD;
Name: STRING [15];
Next: ConfRec;
END;
MsgRec = ^MsgPtr;
MsgPtr = RECORD
Conf : WORD;
Block: LONGINT;
Next : MsgRec;
END;
CONST
author = 'v1.30: January 26, 1996. (c) 1996 by David Daniel Anderson - Reign Ware.';
cursorState: BYTE = 1; {0..3}
cursorData: ARRAY [0..3] OF CHAR = (#179, #47, #196, #92);
lineNumb: LONGINT = 0;
DATname = 'MESSAGES.DAT';
CONname = 'CONTROL.DAT';
VAR
ConfList: ConfRec;
MsgList: MsgRec;
Conferences: WORD;
Blocks: LONGINT;
UserName: STRING [25];
BBSname,
BBSID: STRING;
StartDIR,
TXTQ_DIR: PATHSTR;
{===========================================================================}
PROCEDURE WriteErr (problem: BYTE);
{ PROCEDURE cursorOff; }
PROCEDURE cursorOn;
{ FUNCTION WhereX: BYTE; }
{ FUNCTION WhereY: BYTE; }
{ PROCEDURE GotoXY (X, Y: BYTE); }
{ PROCEDURE WriteCharAtCursor (X: CHAR); }
{ PROCEDURE ClrEol; }
FUNCTION IntToStr (vint: LONGINT): STRING;
FUNCTION LeadingZero (w: WORD): STRING;
PROCEDURE CheckIO;
{ FUNCTION IsFile (CONST filename: PATHSTR): BOOLEAN; }
{ FUNCTION IsDir (CONST filename: PATHSTR): BOOLEAN; }
FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
{ PROCEDURE EraseFile (CONST CurrentFile: STRING); }
{ PROCEDURE EraseAllFiles; }
PROCEDURE updateCursor;
{ PROCEDURE UpFast (VAR Str: STRING); }
{ FUNCTION UpStr (lstr : STRING): STRING; }
FUNCTION RPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
{ FUNCTION LPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING; }
FUNCTION RTrim (InStr: STRING): STRING;
{ FUNCTION LTrim (InStr: STRING): STRING; }
FUNCTION Trim (InStr: STRING): STRING;
FUNCTION StrToDoubleChar (conf: STRING): STRING;
PROCEDURE ReadStr (VAR f : FILE; VAR s : STRING);
{ FUNCTION GetQWKname (Qname: PATHSTR; VAR Qext: EXTSTR): BOOLEAN; }
PROCEDURE PrepareFiles (VAR TextName: PATHSTR; VAR TextExtension: EXTSTR; VAR TextFile: FILE; VAR MsgDAT: FILE);
PROCEDURE AddConfToList (CONST ConfNumStr, ConfName: STRING);
PROCEDURE AddMsgToList (CONST ConfNumStr: STRING; BlockNum: LONGINT);
PROCEDURE Verify (CONST control, variable: STRING; OFFSET: BYTE);
FUNCTION AddToArray (VAR Message: MsgArray; OFFSET: WORD; Line: STRING): WORD;
FUNCTION FigureMSGsize (bytes: WORD; VAR chunks: WORD): STRING;
PROCEDURE InitConfig (VAR Compressor: PATHSTR);
{ FUNCTION GetDateTime: STRING; }
{ PROCEDURE GetBBSID; }
{ PROCEDURE WriteControlDAT (CONST CONname: STRING); }
FUNCTION CompressDAT (CONST QWKfile: STRING; CONST Compressor: PATHSTR): BOOLEAN;
{ FUNCTION WipeDir: BOOLEAN; }
PROCEDURE Cleanup;
{===========================================================================}
IMPLEMENTATION
PROCEDURE WriteErr (problem: BYTE);
VAR
message: STRING;
BEGIN
IF problem > 0 THEN BEGIN
CASE problem OF
1: message := 'Command line error: no files matching specification found to process.';
2: message := 'A ' + DATname+ ' file already exists. MOVE, REName or DELete it.';
3: message := 'Can''t create a unique *.Q?? file. MOVE, REName or DELete some files.';
4: message := 'Invalid header portion encountered just above line number: ' + IntToStr (lineNumb) + ' - fix file!';
5: message := 'Error archiving ' + DATname+ ' - try archiving it manually.';
{ 6: message := ''; }
7: message := 'Unexpected file or directory error, unable to continue.';
ELSE message := 'Unknown error.';
END;
WriteLn (#7, 'Error encountered, number ', problem, ':'); WriteLn (message);
END;
END;
PROCEDURE cursorOff; ASSEMBLER;
(* Routine from SWAG *)
ASM
mov AH, 3; mov BH, 0; Int $10; OR CH, $20; mov AH, 1; Int $10;
END;
PROCEDURE cursorOn; ASSEMBLER;
(* Routine from SWAG *)
ASM
mov AH, 3; mov BH, 0; Int $10; AND CH, NOT $20; mov AH, 1; Int $10;
END;
FUNCTION WhereX: BYTE; ASSEMBLER;
(* Routine from SWAG *)
ASM
MOV AH, 3 {Ask For current cursor position}
MOV BH, 0 { On page 0 }
Int 10h { Return inFormation in DX }
Inc DL { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
MOV AL, DL { Return X position in AL For use in Byte Result }
END;
FUNCTION WhereY: BYTE; ASSEMBLER;
(* Routine from SWAG *)
ASM
MOV AH, 3 {Ask For current cursor position}
MOV BH, 0 { On page 0 }
Int 10h { Return inFormation in DX }
Inc DH { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
MOV AL, DH { Return Y position in AL For use in Byte Result }
END;
PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER;
(* Routine from SWAG *)
ASM
MOV DH, Y { DH = Row (Y) }
MOV DL, X { DL = Column (X) }
Dec DH { Adjust For Zero-based Bios routines }
Dec DL { Turbo Crt.GotoXY is 1-based }
MOV BH, 0 { Display page 0 }
MOV AH, 2 { Call For SET CURSOR POSITION }
Int 10h
END;
PROCEDURE WriteCharAtCursor (X: CHAR);
(* Routine from SWAG *)
VAR
reg: REGISTERS;
BEGIN
reg. AH := $0A;
reg. AL := Ord (X);
reg. BH := $00; {* Display Page Number. * for Graphics Modes! *}
reg. CX := 1; {* Word for number of characters to write *}
Intr ($10, reg);
END;
PROCEDURE ClrEol;
(* Routine by DDA *)
VAR
NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
X, Y, DistanceToRight: BYTE;
BEGIN
X := WhereX;
Y := WhereY;
DistanceToRight := NumCol - X;
Write ('': DistanceToRight);
WriteCharAtCursor (#32);
GotoXY (X, Y);
END;
FUNCTION IntToStr (vint: LONGINT): STRING;
VAR
s: STRING;
BEGIN
Str (vint, s);
IntToStr := s;
END;
FUNCTION LeadingZero (w : WORD) : STRING;
VAR
s : STRING;
BEGIN
Str (w: 0, s);
IF Length (s) = 1 THEN
s := '0' + s;
LeadingZero := s;
END;
PROCEDURE CheckIO;
BEGIN
IF IOResult <> 0 THEN Halt (7);
END;
FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
VAR
Attr : WORD;
cFile : FILE;
BEGIN
Assign (cFile, FileName);
GetFAttr (cFile, Attr);
IF (DosError = 0) AND ((Attr AND Directory) = Directory)
THEN IsDir := TRUE
ELSE IsDir := FALSE;
END;
FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
VAR
Attr : WORD;
cFile : FILE;
BEGIN
Assign (cFile, FileName);
GetFAttr (cFile, Attr);
IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
THEN IsFile := TRUE
ELSE IsFile := FALSE;
END;
FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
VAR
dirinfo : SEARCHREC;
jPath : PATHSTR; { file path, }
jDir : DIRSTR; { directory, }
jName : NAMESTR; { name, }
jExt : EXTSTR; { extension. }
BEGIN
jPath := PStr;
IF jPath = '' THEN jPath := '*.*';
IF (NOT (jPath[Length(jPath)] in [':','\'])) AND IsDir (jPath) THEN
jPath:=jPath+'\';
IF (jPath[Length(jPath)] in [':','\']) THEN
jPath:=jPath+'*.*';
FSplit (FExpand (jPath), jDir, jName, jExt);
jPath := jDir+jName+jExt;
sDir := jDir;
GetFilePath := jPath;
END;
PROCEDURE EraseFile (CONST FileName : STRING);
VAR
cFile : FILE;
BEGIN
IF IsFile (FileName) THEN BEGIN
Assign (cFile, FileName);
SetFAttr (cFile, 0);
Erase (cFile); CheckIO;
END;
END;
PROCEDURE EraseAllFiles;
VAR
JustFiles: WORD;
DirInfo : SEARCHREC;
BEGIN
JustFiles := ReadOnly + Hidden + SysFile + Archive;
FindFirst ('*.*', JustFiles, DirInfo);
WHILE DosError = 0 DO
BEGIN
EraseFile (DirInfo. Name);
FindNext (DirInfo);
END;
END;
PROCEDURE updateCursor;
{code written by Sean Palmer, found in SWAG}
BEGIN
cursorState := Succ (cursorState) AND 3;
Write (cursorData [cursorState], ^H);
END;
PROCEDURE UpFast (VAR Str: STRING); {** from SWAG **}
INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
$AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
FUNCTION UpStr (lstr : STRING): STRING;
BEGIN
upfast (lstr);
UpStr := lstr;
END;
FUNCTION RPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := bstr + pChar;
RPad := bstr;
END;
FUNCTION LPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := pChar + bstr;
LPad := bstr;
END;
FUNCTION RTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
Dec (InStr [0]);
RTrim := InStr;
END;
FUNCTION LTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
Delete (InStr, 1, 1);
LTrim := InStr;
END;
FUNCTION Trim (InStr: STRING): STRING;
BEGIN
Trim := RTrim (LTrim (InStr));
END;
FUNCTION StrToDoubleChar (conf: STRING): STRING;
VAR
i, VErr: INTEGER;
BEGIN
Conf := Trim (conf);
Val (conf, i, VErr);
IF (VErr = 0)
THEN StrToDoubleChar := Chr (i MOD 256) + Chr (i DIV 256)
ELSE StrToDoubleChar := #0#0
END;
PROCEDURE ReadStr (VAR f : FILE; VAR s : STRING);
VAR
s1 : ARRAY [1..255] OF CHAR;
BytesRead : WORD;
crlf, p, i : INTEGER;
fp : LONGINT;
BEGIN
s := '';
crlf := 0;
fp := FilePos (f);
BlockRead (f, s1, SizeOf (s1), BytesRead);
IF (BytesRead > 0) THEN { if at EOF, go no further }
BEGIN
s [0] := Chr (BytesRead);
FOR i := 1 TO BytesRead DO
s [i] := s1 [i];
p := Pos (#13#10, s);
IF (p > 0) THEN
BEGIN
s := Copy (s, 1, p - 1);
crlf := 2;
END;
Seek (f, fp + crlf + Length (s));
END;
END;
FUNCTION GetQWKname (Qname: PATHSTR; VAR Qext: EXTSTR): BOOLEAN;
VAR
letter3,
letter4: CHAR;
UniqueNameFound, NamesExhausted: BOOLEAN;
BEGIN
UniqueNameFound := FALSE;
NamesExhausted := FALSE;
letter3 := '0';
letter4 := '0';
IF NOT IsFile (Qname+ '.QWK') THEN
Qext := '.QWK'
ELSE
WHILE (NOT UniqueNameFound) AND (NOT NamesExhausted) DO
BEGIN
Qext := '.Q' + letter3 + letter4;
IF NOT IsFile (Qname + Qext) THEN
UniqueNameFound := TRUE
ELSE { incremenent extension }
CASE letter4 OF
'Z': BEGIN
letter4 := '0';
CASE letter3 OF
'Z': NamesExhausted := TRUE;
'9': letter3 := 'A';
ELSE Inc (letter3);
END;
END;
'9': letter4 := 'A';
ELSE Inc (letter4);
END;
END;
GetQWKname := (NOT NamesExhausted)
END;
PROCEDURE PrepareFiles (VAR TextName: PATHSTR; VAR TextExtension: EXTSTR;
VAR TextFile: FILE; VAR MsgDAT: FILE);
CONST
QmailLine: ARRAY [1..128] OF CHAR =
'Produced by Qmail...Copyright (c) 1995 by SparkWare. All Rights' +
' Reserved Above for Compatibility with Qmail ';
VAR
QWKname: PATHSTR;
BEGIN
IF IsFile (DATname) THEN Halt (2);
IF NOT IsFile (TextName) THEN Halt (1);
Assign (TextFile, TextName);
Reset (TextFile, 1); CheckIO;
QWKname := TextName;
IF (Pos ('.', QWKname) > 0) THEN
QWKname := Copy (QWKname, 1, Pos ('.', QWKname) - 1);
IF NOT GetQWKname (QWKname, TextExtension) THEN Halt (3);
cursorOff;
Write ('Converting ', TextName, ' to ', DATname, ' please wait ... ');
TextName := QWKname;
Assign (MsgDAT, DATname);
Rewrite (MsgDAT, 1); CheckIO;
BlockWrite (MsgDAT, QmailLine, 128); CheckIO;
END;
PROCEDURE AddConfToList (CONST ConfNumStr, ConfName: STRING);
(* Routine from SWAG *)
{ This Procedure will search through an ordered linked list,
find out where the data belongs, and insert it into the list. }
VAR
Anchor, { Where we are in the list }
NewConf: ConfRec; { This is what we insert our data into. }
ConfNum: WORD;
BEGIN
ConfNum := Ord (ConfNumStr [1]) + (256 * (Ord (ConfNumStr [2])));
Inc (Conferences);
New (NewConf);
Anchor := ConfList; { Start at the top of the list. }
IF ConfList = NIL THEN
BEGIN
ConfList := NewConf;
ConfList^.Num := ConfNum;
ConfList^.Name := ConfName;
ConfList^.Next := NIL;
END
ELSE { Check to see if it comes before the first item in the list }
IF ConfNum < Anchor^.Num THEN
BEGIN
NewConf^.Next := ConfList; { Make the Anchor first come after Next }
ConfList := NewConf; { This is our new ConfList of the list }
ConfList^.Num := ConfNum; { and insert our data value(s). }
ConfList^.Name := ConfName;
END
ELSE
BEGIN
{ Here we need to go through the list, but always looking one step
ahead of where we are, so we can maintain the links. The method
we'll use here is: looking at Anchor^.Next^.Num
A way to explain that in English is "what is the data pointed to by
Pointer Next, in the Record pointed to by Pointer Anchor." You may
need to run that through your List a few times before it clicks, but
hearing it in English might make it a bit easier for some people to
understand. }
WHILE (Anchor^.Next <> NIL) AND (ConfNum >= Anchor^.Next^.Num) DO
Anchor := Anchor^.Next;
IF ConfNum = Anchor^.Num THEN {This clause prevents duplicate numbers}
BEGIN
Dispose (NewConf);
Dec (Conferences);
END
ELSE
BEGIN
NewConf^.Num := ConfNum;
NewConf^.Name := ConfName;
NewConf^.Next := Anchor^.Next;
Anchor^.Next := NewConf;
END;
END;
END;
PROCEDURE AddMsgToList (CONST ConfNumStr: STRING; BlockNum: LONGINT);
(* Routine from SWAG *)
{ This Procedure will search through an ordered linked list,
find out where the data belongs, and insert it into the list. }
VAR
Anchor, { Where we are in the list }
NewMsg: MsgRec; { This is what we insert our data into. }
ConfNum: WORD;
BEGIN
ConfNum := Ord (ConfNumStr [1]) + (256 * (Ord (ConfNumStr [2])));
New (NewMsg);
Anchor := MsgList; { Start at the top of the list. }
IF MsgList = NIL THEN
BEGIN
MsgList := NewMsg;
MsgList^.Conf := ConfNum;
MsgList^.Block := BlockNum;
MsgList^.Next := NIL;
END
ELSE { Check to see if it comes before the first item in the list }
IF ConfNum < Anchor^.Conf THEN
BEGIN
NewMsg^.Next := MsgList; { Make the Anchor first come after Next }
MsgList := NewMsg; { This is our new MsgList of the list }
MsgList^.Conf := ConfNum; { and insert our data value(s). }
MsgList^.Block := BlockNum;
END
ELSE
BEGIN
{ Here we need to go through the list, but always looking one step
ahead of where we are, so we can maintain the links. The method
we'll use here is: looking at Anchor^.Next^.Conf
A way to explain that in English is "what is the data pointed to by
Pointer Next, in the Record pointed to by Pointer Anchor." You may
need to run that through your List a few times before it clicks, but
hearing it in English might make it a bit easier for some people to
understand. }
WHILE (Anchor^.Next <> NIL) AND (ConfNum >= Anchor^.Next^.Conf) DO
Anchor := Anchor^.Next;
NewMsg^.Conf := ConfNum;
NewMsg^.Block := BlockNum;
NewMsg^.Next := Anchor^.Next;
Anchor^.Next := NewMsg;
END;
END;
PROCEDURE Verify (CONST control, variable: STRING; OFFSET: BYTE);
BEGIN
IF (Copy (control, OFFSET, Length (variable)) <> variable) THEN
Halt (4);
END;
FUNCTION AddToArray (VAR Message: MsgArray; OFFSET: WORD; Line: STRING): WORD;
VAR
index: WORD;
BEGIN
IF (OFFSET > 128) THEN { remove trailing whitespace }
Line := RTrim (Line);
IF (Length (Line) > 0) THEN BEGIN
FOR index := (OFFSET + 1) TO (OFFSET + Length (Line)) DO BEGIN
IF (index <= MaxBytes) THEN
Message [index] := Line [index - OFFSET];
END
END
ELSE index := OFFSET;
IF (OFFSET >= 128) AND (index < MaxBytes) THEN BEGIN
Inc (index);
Message [index] := #227;
END;
AddToArray := index;
END;
FUNCTION FigureMSGsize (bytes: WORD; VAR chunks: WORD): STRING;
VAR
MsgChunks: STRING [6];
BEGIN
chunks := (bytes DIV 128);
IF ((bytes MOD 128) <> 0) THEN Inc (chunks);
Str (chunks, MsgChunks);
MsgChunks := RPad (MsgChunks, 6, #32);
FigureMSGsize := MsgChunks;
END;
PROCEDURE InitConfig (VAR Compressor: PATHSTR);
VAR
epath: PATHSTR;
edir : DIRSTR;
ename: NAMESTR;
eext : EXTSTR;
CfgFile: TEXT;
CfgLine,
CfgVar, CfgVal: STRING [80];
equalPos: BYTE;
BEGIN
FSplit (FExpand (ParamStr (0)), edir, ename, eext); { break up path into components }
epath := edir + ename + '.cfg';
Compressor := 'pkzip -# -m';
UserName := 'USER NAME';
BBSID := '';
IF IsFile (epath) THEN
BEGIN
Assign (CfgFile, epath);
Reset (CfgFile); CheckIO;
WHILE NOT EoF (CfgFile) DO BEGIN { find vars }
ReadLn (CfgFile, CfgLine);
equalPos := Pos ('=', CfgLine);
IF (equalPos > 1) THEN BEGIN
CfgVar := Trim (UpStr (Copy (CfgLine, 1, equalPos - 1)));
CfgVal := Trim (Copy (CfgLine, equalPos + 1, Length (CfgLine) - equalPos));
IF (CfgVar = 'COMPRESSOR') THEN
Compressor := CfgVal
ELSE IF (CfgVar = 'USERNAME') THEN
UserName := Copy (CfgVal, 1, 25)
ELSE IF (CfgVar = 'BBSID') THEN
BBSID := Copy (CfgVal, 1, 8)
END;
END; { loop back to read another line }
Close (CfgFile);
END;
END;
FUNCTION GetDateTime: STRING;
VAR
Y, m, D, dow,
h, i, s, s100: WORD;
Ys: STRING [4];
BEGIN
GetDate (Y, m, D, dow);
GetTime (h, i, s, s100);
Str (Y, Ys);
GetDateTime := LeadingZero (M) + '-' +
LeadingZero (D) + '-' +
(Ys) + ',' +
LeadingZero (H) + ':' +
LeadingZero (I) + ':' +
LeadingZero (S)
END;
PROCEDURE GetBBSID;
BEGIN
BBSID := Trim (BBSID);
IF BBSID = '' THEN BEGIN
BBSID := Copy (UpStr (Trim (BBSname)), 1, 8);
IF Pos (#32, BBSID) <> 0 THEN
BBSID := Copy (BBSID, 1, Pos (#32, BBSID) - 1);
IF BBSID = '' THEN BBSID := 'BBSID';
END;
IF BBSname = '' THEN BBSname := 'BBS name';
IF Length (BBSID) > 8 THEN BBSID := Trim (Copy (BBSID,1,8));
END;
PROCEDURE WriteControlDAT (CONST CONname: STRING);
VAR
link: ConfRec;
cDat: TEXT;
BEGIN
GetBBSID;
Assign (cDat, CONname);
Rewrite (cDat);
WriteLn (cDat, BBSname);
WriteLn (cDat, 'City, ST');
WriteLn (cDat, '000-000-0000');
WriteLn (cDat, 'Your Sysop, Sysop');
WriteLn (cDat, '00000,', BBSID);
WriteLn (cDat, GetDateTime); {in the format: 10-15-1995,06:44:36}
WriteLn (cDat, UserName);
WriteLn (cDat);
WriteLn (cDat, '0');
WriteLn (cDat, '0');
WriteLn (cDat, Conferences - 1);
WHILE ConfList <> NIL DO BEGIN
WITH ConfList^ DO BEGIN
WriteLn (cDat, Num);
WriteLn (cDat, Name);
END;
link := ConfList;
ConfList := ConfList^.next;
Dispose (link);
END;
Close (cDat);
END;
PROCEDURE WriteNDXfiles;
TYPE
bsingle = ARRAY [0..4] OF BYTE;
VAR
link: MsgRec;
NDXfile: FILE;
NDXname: STRING [12];
LastConf: LONGINT;
MSbinary : bSingle;
realTemp : REAL;
{ converts TP real to Microsoft 4 bytes single ... }
PROCEDURE real_to_msb (preal : REAL; VAR MSbinary : bsingle);
VAR
realTemp : ARRAY [0 .. 5] OF BYTE ABSOLUTE preal;
BEGIN
MSbinary [3] := realTemp [0];
Move (realTemp [3], MSbinary [0], 3);
END; { procedure real_to_msb }
BEGIN
LastConf := -1;
WHILE MsgList <> NIL DO BEGIN
WITH MsgList^ DO BEGIN
IF (Conf <> LastConf) THEN BEGIN
IF (LastConf <> -1) THEN
Close (NDXfile); CheckIO;
LastConf := Conf;
Str (Conf, NDXname);
NDXname := LPad (NDXname, 3, '0') + '.NDX';
Assign (NDXfile, NDXname);
Rewrite (NDXfile, 1); CheckIO;
END;
realTemp := Block; { make a REAL }
REAL_TO_MSB (realTemp, MSbinary); { convert to MSB format }
MSbinary [4] := Conf MOD 256; { put in a dummy conference number }
BlockWrite (NDXfile, MSbinary, SizeOf (MSbinary)); { store it }
CheckIO;
END;
link := MsgList;
MsgList := MsgList^.next;
Dispose (link);
END;
IF (LastConf <> - 1) THEN
Close (NDXfile); CheckIO;
END;
FUNCTION CompressDAT (CONST QWKfile: STRING; CONST Compressor: PATHSTR): BOOLEAN;
VAR
X, Y, newX: BYTE;
BEGIN
IF NOT IsFile (CONname) THEN
WriteControlDAT (CONname);
WriteNDXfiles;
X := WhereX;
Y := WhereY;
Write ('> ', Compressor);
newX := WhereX;
DosError := HeapMan. Execute (GetEnv ('COMSPEC'), ' /c ' + compressor + ' ' + QWKfile+ ' *.* >NUL');
IF DosError <> 0 THEN Halt (5);
IF (Y = WhereY) AND (WhereX >= newX) THEN
BEGIN {If we haven't moved to a new line... }
GotoXY (X, Y); {return to where we were at start of procedure}
ClrEol;
END;
cursorOff;
CompressDAT := IsFile (QWKfile)
END;
FUNCTION WipeDir: BOOLEAN;
VAR
CurrDir: PATHSTR;
BEGIN
GetDir (0, CurrDir);
IF CurrDir = TXTQ_DIR THEN BEGIN
EraseAllFiles;
ChDir (StartDIR); CheckIO;
RmDir (TXTQ_DIR); CheckIO;
END;
WipeDir := (NOT IsDir (TXTQ_DIR))
END;
PROCEDURE Cleanup;
BEGIN
IF NOT WipeDir THEN BEGIN
WriteLn;
WriteLn ('*** ABNORMAL PROGRAM TERMINATION, WORK DIRECTORY STILL EXISTS! ***');
WriteLn;
END;
END;
BEGIN
GetDir (0, StartDIR);
IF StartDir [Length (StartDir)] <> '\'
THEN TXTQ_DIR := '\'
ELSE TXTQ_DIR := '';
TXTQ_DIR := StartDIR + TXTQ_DIR + 'TXTQ_DIR.!!!';
END.